unit FUtils;

interface
uses
  SysUtils, Controls, Classes, Menus, ActnList, Windows, Forms, Dialogs,
  Graphics, Checklst, Math, WinSock, ActiveX, ComObj, VarUtils, Registry,
  StrUtils, ShellAPI, DB, Variants, Jpeg, GIFImage, TLhelp32, EncdDecd;

type
  TRegComClassType = (rctDll, rctExe);
  TRegAction = (raReg, raUnreg, raExecute);
  TRegProc = function : HResult; stdcall;
  
function ComClassRegistered(ProgID: String): Boolean;
function RegisterComClass(ProgID: String; ComClassType: TRegComClassType): Boolean;
function GetFileNameByProgID(ProgID: String; ComClassType: TRegComClassType): String;
function RegisterAxLib(pOcxFileName: String; pRegAction: TRegAction): Boolean;
function RegisterExe(pExeFileName: String; pRegAction: TRegAction): Boolean;
procedure ComClassCheck(ProgID: String; ComClassType: TRegComClassType);

function GetInprocServer32(AClassID: TGUID): String;
function GetLocalServer32(AClassID: TGUID): String;


function StreamToByteArray(var Dest: TVarData; Stream: TMemoryStream;
                           AStartPos: DWord = 0; ACount: Integer = 0): HRESULT;
function ByteArrayToStream(var Dest: TVarData; Stream: TMemoryStream;
                           AStartPos: DWord = 0): HRESULT;

implementation

function RegisterComClass(ProgID: String; ComClassType: TRegComClassType): Boolean;
var
  sFileName: String;
begin
  Result := ComClassRegistered(ProgID);
  if Not Result then
  begin
    sFileName := GetFileNameByProgID(ProgID, ComClassType);
    if sFileName <> '' then
    begin
      if ComClassType = rctDll then
        Result := RegisterAxLib(sFileName, raReg)
      else
        Result := RegisterExe(sFileName, raReg);
    end;
  end;
end;

function ComClassRegistered(ProgID: String): Boolean;
var
  oGUID: TGUID;
begin
  Result := (CLSIDFromProgID(PWideChar(WideString(ProgID)), oGUID) = S_OK);
end;

function GetFileNameByProgID(ProgID: String; ComClassType: TRegComClassType): String;
var
  i: Integer;
begin
  Result := '';
  i := Pos('.', ProgID);
  if i > 0 then
  begin
    if ComClassType = rctDll then
      Result := Format('%S.dll', [Copy(ProgID, 1, i - 1)])
    else
      Result := Format('%S.exe', [Copy(ProgID, 1, i - 1)]);
  end;
end;

function RegisterAxLib(pOcxFileName: String; pRegAction: TRegAction): Boolean;
const
  SCantFindProc = '%s procedure not found in "%s"';
  SRegFail = 'Call to %s failed in "%s"';
  SLoadFail = 'Failed to load "%s"';
  ProcName: array[TRegAction] of PChar = ('DllRegisterServer', 'DllUnregisterServer', '');
var
  LibHandle: THandle;
  RegProc: TRegProc;
  DirBuffer, FileName, ExtendPath: String;
begin
  Result := False;
  if ExtractFilePath(pOcxFileName) = '' then
  begin
    DirBuffer := GetModuleName(GetModuleHandle(Nil));
    FileName := ExtractFileDir(DirBuffer) + '\' + pOcxFileName;
  end
  else begin
    FileName := pOcxFileName;
    if Not FileExists(FileName) then
      Exit;
  end;
  LibHandle := LoadLibrary(PChar(FileName));
  if LibHandle = 0 then
    Raise Exception.CreateFmt(SLoadFail, [FileName]);
  Try
    @RegProc := GetProcAddress(LibHandle, ProcName[pRegAction]);
    if @RegProc = Nil then
      Raise Exception.CreateFmt(SCantFindProc, [ProcName[pRegAction], FileName]);
    if RegProc <> 0 then
      Raise Exception.CreateFmt(SRegFail, [ProcName[pRegAction], FileName]);
    Result := True;
  Finally
    FreeLibrary(LibHandle);
  End;
end;

function RegisterExe(pExeFileName: String; pRegAction: TRegAction): Boolean;
const
  ExeFlags: array[TRegAction] of string = (' /regserver', ' /unregserver', '');
  SExeRegUnsuccessful = '%s failed.';
var
  SI: TStartupInfo;
  PI: TProcessInformation;
  RegisterExitCode: BOOL;
  DirBuffer, FileName, ExtendPath: String;
begin
  Result := False;
  if ExtractFilePath(pExeFileName) = '' then
  begin
    DirBuffer := GetModuleName(GetModuleHandle(Nil));
    FileName := ExtractFileDir(DirBuffer) + '\' + pExeFileName;
  end
  else begin
    FileName := pExeFileName;
    if Not FileExists(FileName) then
      Exit;
  end;
  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  RegisterExitCode := Win32Check(CreateProcess(PChar(FileName), PChar(FileName + ExeFlags[pRegAction]),
                                               Nil, Nil, True, 0, Nil, Nil, SI, PI));
  if pRegAction <> raExecute then
  begin
    CloseHandle(PI.hThread);
    CloseHandle(PI.hProcess);
    if Not RegisterExitCode then
      Raise Exception.Create(Format(SExeRegUnsuccessful, [PChar(FileName + ExeFlags[pRegAction])]));
  end;
  Result := True;
end;

procedure ComClassCheck(ProgID: String; ComClassType: TRegComClassType);
var
  sFileName: String;
begin
  if ComClassRegistered(ProgID) then
  begin
    if ComClassType = rctDll then
      sFileName := GetInprocServer32(ProgIDToClassID(ProgID))
    else
      sFileName := GetLocalServer32(ProgIDToClassID(ProgID));
    if Not FileExists(sFileName) then
      Raise Exception.Create(Format('ComClass file not found! "%S"', [sFileName]));
  end
  else begin
    Raise Exception.Create(Format('ComClass file not register! "%S"',
                                  [GetFileNameByProgID(ProgID, ComClassType)]));
  end;
end;

function GetInprocServer32(AClassID: TGUID): String;
var
  sRegPath: String;
begin
  With TRegIniFile.Create Do
  begin
    Try
      RootKey := HKEY_LOCAL_MACHINE;
      sRegPath := Format('\SOFTWARE\Classes\CLSID\%S\InprocServer32', [GUIDToString(AClassID)]);
      Result := ReadString(sRegPath, '', '');
      if Result = '' then
      begin
        RootKey := HKEY_CLASSES_ROOT;
        sRegPath := Format('\CLSID\%S\InprocServer32', [GUIDToString(AClassID)]);
        Result := ReadString(sRegPath, '', '');
      end;
    Finally
      Free;
    End;
  end;
end;

function GetLocalServer32(AClassID: TGUID): String;
var
  sRegPath: String;
begin
  With TRegIniFile.Create Do begin
    Try
      RootKey := HKEY_LOCAL_MACHINE;
      sRegPath := Format('\SOFTWARE\Classes\CLSID\%S\LocalServer32', [GUIDToString(AClassID)]);
      Result := ReadString(sRegPath, '', '');
      if Result = '' then
      begin
        RootKey := HKEY_CLASSES_ROOT;
        sRegPath := Format('\CLSID\%S\LocalServer32', [GUIDToString(AClassID)]);
        Result := ReadString(sRegPath, '', '');
      end;
    Finally
      Free;
    End;
  end;
end;


function StreamToByteArray(var Dest: TVarData; Stream: TMemoryStream;
                           AStartPos: DWord = 0; ACount: Integer = 0): HRESULT;
var
  P: Pointer;
  LArray: PVarArray;
  LData: Pointer;
  LCount: Integer;
  LVarBounds: Array[0..0] Of TVarArrayBound;
begin
  Result := VAR_OK;
  if AStartPos = 0 then LCount := Stream.Size
    else LCount := ACount;
  LVarBounds[0].LowBound := 0;
  LVarBounds[0].ElementCount := LCount;
  LArray := SafeArrayCreate(varByte, 1, PVarArrayBoundArray(@LVarBounds)^);
  Try
    Result := SafeArrayLock(LArray);
    if Result = VAR_OK then
    Try
      Result := SafeArrayAccessData(LArray, LData);
      if Result = VAR_OK then
      Try
        P := Pointer(DWord(Stream.Memory) + AStartPos); 
        Move(P^, LData^, LCount)
      Finally
        Result := SafeArrayUnaccessData(LArray);
      End;
    Finally
      if Result = VAR_OK then
        Result := SafeArrayUnlock(LArray)
      else
        SafeArrayUnlock(LArray);
    End;
  Finally
    if Result <> VAR_OK then
      SafeArrayDestroy(LArray)
    else begin
      Dest.VType := varArray + varByte;
      Dest.VArray := LArray;
    end;
  End;
end;

function ByteArrayToStream(var Dest: TVarData; Stream: TMemoryStream;
                           AStartPos: DWord = 0): HRESULT;
var
  P: Pointer;
  LArray: PVarArray;
  LData: Pointer;
  LCount: DWord;
begin
  LArray := Dest.VArray;
  Result := SafeArrayLock(LArray);
  if Result = VAR_OK then
  Try
    Result := SafeArrayAccessData(LArray, LData);
    if Result = VAR_OK then
    Try
      LCount := LArray.Bounds[0].ElementCount;
      if AStartPos = 0 then
        Stream.Size := LCount
      else if AStartPos + LCount > Stream.Size then
        Stream.Size := AStartPos + LCount;
      P := Pointer(DWord(Stream.Memory) + AStartPos);
      Move(LData^, P^, LCount);
    Finally
      Result := SafeArrayUnaccessData(LArray);
    End;
  Finally
    if Result = VAR_OK then
      Result := SafeArrayUnlock(LArray)
    else
      SafeArrayUnlock(LArray);
  End;
end;

end.
